Dim App As Object
Dim Cmds As Object
Dim Part As Object
Dim Overproof As Integer
Sub Out_of_DIM_ID()
    On Error Resume Next
    Application.StatusBar = "数据提取中......"
    Set App = CreateObject("Pcdlrn.Application")
    Set Part = App.ActivePartProgram
    Set Cmds = Part.Commands
    Dim Cmd As Command
    Dim TEM As Integer
    Dim CountM As Integer
    Dim StatusBarCount As Integer
    Dim VH As Integer
    Dim Meas As Double
    Dim idsToExclude As Variant
    TEM = Cells(1, 1).Value
    VH = 5
    StatusBarCount = 1
    For Each Cmd In Cmds
        DoEvents
        If Cmd.IsDimension Or Cmd.IsFCFCommand Then
            If Cmd.Marked = True Then
                '--------------------------------------------------------------------------------------------------------------------------------
                If Cmd.GetText(LINE2_MEAS, 1) = "" Then
                    Application.StatusBar = "传统 尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                    Meas = Cmd.DimensionCommand.Measured
                    
                    idsToExclude = Array("", "A", "B", "C", "D", "E", "F")
                    If Not IsInArray(Cmd.DimensionCommand.ID, idsToExclude) Then
                        Cells(VH, 1).Value = Cmd.DimensionCommand.ID
                        If Cmd.DimensionCommand.Nominal <> 0 Then
                            Cells(VH, 2).Value = Cmd.DimensionCommand.Nominal
                        Else
                            Cells(VH, 2).Value = Cmd.GetText(Nominal, 1)
                        End If
                        If Cmd.DimensionCommand.Plus <> 0 Then
                            Cells(VH, 3).Value = Cmd.DimensionCommand.Plus
                        Else
                            Cells(VH, 3).Value = Cmd.GetText(F_PLUS_TOL, 1)
                        End If
                        If Cmd.DimensionCommand.Minus <> 0 Then
                            Cells(VH, 4).Value = Cmd.DimensionCommand.Minus
                        Else
                            Cells(VH, 4).Value = Cmd.GetText(F_MINUS_TOL, 1)
                        End If
                        If Cmd.GetText(REF_ID, 1) <> "" And Cmd.GetText(REF_ID, 2) <> "" Then
                            If Cmd.GetText(REF_ID, 1) = Cmd.GetText(REF_ID, 2) Then
                                Cells(VH, 20).Value = Cmd.GetText(REF_ID, 3)
                            Else
                                Cells(VH, 20).Value = Cmd.GetText(REF_ID, 1) & "[" & Cmd.GetText(REF_ID, 3) & "]" & Cmd.GetText(REF_ID, 2)
                            End If
                        Else
                            Cells(VH, 20).Value = Cmd.GetText(REF_ID, 3)
                        End If
                        VH = VH + 1
                    End If
                End If
                CountM = 1
                If Cmd.GetText(LINE2_MEAS, 1) <> "" Then
                    Do
                        Application.StatusBar = "位置度尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                        Meas = Cmd.GetText(LINE2_MEAS, CountM)
                        Cells(VH, 1).Value = Cmd.FCFCommand.ID
                        If Cmd.GetText(LINE2_NOMINAL, CountM) <> "" Then
                            Cells(VH, 2).Value = Cmd.GetText(LINE2_NOMINAL, CountM)
                        Else
                            Cells(VH, 2).Value = Cmd.GetText(Nominal, CountM)
                        End If
                        If Cmd.GetText(LINE2_PLUSTOL, CountM) <> "" Then
                            Cells(VH, 3).Value = Cmd.GetText(LINE2_PLUSTOL, CountM)
                        Else
                            Cells(VH, 3).Value = Cmd.GetText(F_PLUS_TOL, CountM)
                        End If
                        If Cmd.GetText(LINE2_MINUSTOL, CountM) <> "" Then
                            Cells(VH, 4).Value = Cmd.GetText(LINE2_MINUSTOL, CountM)
                        Else
                            Cells(VH, 4).Value = Cmd.GetText(F_MINUS_TOL, CountM)
                        End If
                        Cells(VH, 20).Value = Cmd.GetText(REF_ID, CountM)
                        CountM = CountM + 1
                        If Meas <> "" Then VH = VH + 1
                    Loop While Cmd.GetText(LINE2_MEAS, CountM) <> ""
                End If
                CountM = 1
                If Cmd.GetText(SUMMARY_MEAS, 1) <> "" Then
                    Do
                        Application.StatusBar = "位置 尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                        Meas = Cmd.GetText(SUMMARY_MEAS, CountM)
                        Cells(VH, 1).Value = Cmd.ID
                        Cells(VH, 2).Value = Cmd.GetText(SUMMARY_NOMINAL, CountM)
                        Cells(VH, 3).Value = Cmd.GetText(SUMMARY_PLUSTOL, CountM)
                        Cells(VH, 4).Value = Cmd.GetText(SUMMARY_MINUSTOL, CountM)
                        Cells(VH, 20).Value = Cmd.GetText(SUMMARY_FEAT, CountM)
                        CountM = CountM + 1
                        If Meas <> "" Then VH = VH + 1
                    Loop While Cmd.GetText(SUMMARY_MEAS, CountM) <> ""
                End If
            End If
        End If
        StatusBarCount = StatusBarCount + 1
    Next
    Application.StatusBar = "已完成数据提取"
    
End Sub
Sub fenghaiyang()
    On Error Resume Next
    If Cells(5, 1) = "" Then Call Out_of_DIM_ID
    Application.StatusBar = "数据提取中......"
    Set App = CreateObject("Pcdlrn.Application")
    Set Part = App.ActivePartProgram
    Set Cmds = Part.Commands
    Dim Cmd As Command
    Dim TEM As Integer
    Dim CountM As Integer
    Dim StatusBarCount As Integer
    Dim VH As Integer
    Dim Meas As Double
    TEM = Cells(1, 1).Value
    VH = 5
    StatusBarCount = 1
    For Each Cmd In Cmds
        DoEvents
        If Cmd.IsDimension Or Cmd.IsFCFCommand Then
            If Cmd.Marked = True Then
                '--------------------------------------------------------------------------------------------------------------------------------
                If Cmd.GetText(LINE2_MEAS, 1) = "" Then 'Cmd.GetText(LINE2_MEAS, 1)传统尺寸
                    Application.StatusBar = "传统 尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                    Meas = Cmd.DimensionCommand.Measured
                    If Meas <> 0 Then
                        Cells(VH, TEM).Value = Meas
                        Call Out_Of_Tolerance(Meas, VH, TEM)
                        If Meas <> "" Then VH = VH + 1
                    End If
                End If
                
                '--------------------------------------------------------------------------------------------------------------------------------
                CountM = 1
                If Cmd.GetText(LINE2_MEAS, 1) <> "" Then 'Cmd.GetText(LINE2_MEAS, CountM)位置度轮廓度...尺寸
                    Do
                        Application.StatusBar = "位置度尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                        Meas = Cmd.GetText(LINE2_MEAS, CountM)
                        Cells(VH, TEM).Value = Meas
                        Call Out_Of_Tolerance(Meas, VH, TEM)
                        CountM = CountM + 1
                        If Meas <> "" Then VH = VH + 1
                    Loop While Cmd.GetText(LINE2_MEAS, CountM) <> ""
                End If
                
                '--------------------------------------------------------------------------------------------------------------------------------
                CountM = 1
                If Cmd.GetText(SUMMARY_MEAS, 1) <> "" Then '位置尺寸 X Y Z ....
                    Do
                        Application.StatusBar = "位置 尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                        Meas = Cmd.GetText(SUMMARY_MEAS, CountM)
                        Cells(VH, TEM).Value = Meas
                        Call Out_Of_Tolerance(Meas, VH, TEM)
                        CountM = CountM + 1
                        If Meas <> "" Then VH = VH + 1
                    Loop While Cmd.GetText(SUMMARY_MEAS, CountM) <> ""
                End If
                
                '--------------------------------------------------------------------------------------------------------------------------------
                CountM = 1
                If Cells(1, 15) = 1 Then
                    If Cmd.DimensionCommand = FEATURE_CONTROL_FRAME Then
                        If Cmd.GetText(LINE2_MAX, 1) <> "" Then '形位公差最大值
                            Meas = Cmd.GetText(LINE2_MAX, CountM)
                            Application.StatusBar = "最大值尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                            Cells(VH, TEM).Value = Meas
                            CountM = CountM + 1
                            If Meas <> "" Then VH = VH + 1
                        End If
                        CountM = 1
                        If Cmd.GetText(LINE2_MIN, 1) <> "" Then '形位公差最小值
                            Meas = Cmd.GetText(LINE2_MIN, CountM)
                            Application.StatusBar = "最小值尺寸 数据提取中......%" & Int((StatusBarCount / Cmds.Count) * 100)
                            Cells(VH, TEM).Value = Meas
                            CountM = CountM + 1
                            If Meas <> "" Then VH = VH + 1
                        End If
                        CountM = 1
                    End If
                End If
                
                '--------------------------------------------------------------------------------------------------------------------------------
            End If
        End If
        StatusBarCount = StatusBarCount + 1
    Next
    Cells(1, 1).Value = TEM + 1
    Cells(VH + 1, TEM).Value = Date & "_" & Time
    Application.StatusBar = "已完成数据提取"
End Sub
Public Sub Out_Of_Tolerance(Meas As Double, VH As Integer, TEM As Integer)
    If Val(Meas) <= Val(Cells(VH, 5).Value) And Meas >= Val(Cells(VH, 6).Value) Then
        If Cells(1, 19) = 1 Then
            Rows(VH).Select
            Selection.EntireRow.Hidden = True
        End If
    Else
        If Val(Meas) > Val(Cells(VH, 5).Value) Then
            Cells(VH, TEM + 1).Value = (Cells(VH, TEM).Value) - Cells(VH, 5).Value
            If Cells(VH, TEM + 1).Value > 0.1 Then Overproof = Overproof + 1
        End If
        If Val(Meas) < Val(Cells(VH, 6).Value) Then
            Cells(VH, TEM + 1).Value = (Cells(VH, TEM).Value) - Cells(VH, 6).Value
            If Cells(VH, TEM + 1).Value < -0.1 Then Overproof = Overproof + 1
        End If
        
    End If
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Sub BackIng() '备份工作表
    Dim DL As String, ML As String
    DS = VBA.Format(VBA.Date, "YYYY_MM_DD")
    DM = VBA.Format(VBA.Time, "HH_MM_SS")
    Dim ACSName
    ACSName = ThisWorkbook.Name
    DL = ThisWorkbook.Path & "\" & ACSName
    ML = "D:\Data" & "\" & DS & "_" & DM & "\"
    VBA.Shell Environ$("comspec") & " /c xcopy " & DL & " " & ML, vbHide
    
    If Overproof > 0 Then
        Dim UInput As String
        Dim Response As Integer
        Response = MsgBox("监测到有超差0.10以上尺寸", vbQuestion + vbYesNo, "确认是否发送邮件到指定邮箱")
        If Response = vbYes Then
            Dim Shell As Object
            Set Shell = CreateObject("WScript.Shell")
            Dim ThisName As String
            ThisName = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1)
            ThisName = "Form_" & VBA.Environ("computername") & "_FileName_" & VBA.Trim(ThisName)
            Dim Command As String
            Command = "send_email.exe " & VBA.Trim(ThisName) & " " & ML & ACSName
            Dim ExitCode As Integer
            ExitCode = Shell.Run(Command, 0, True)
            If ExitCode = 0 Then
              Application.StatusBar = "发送成功"
            Else
              Application.StatusBar = "发送失败"
            End If
        Else
            Overproof = 0
        End If
    End If
    Overproof = 0
End Sub

